;;; Some basic geometry used here and there

(defpackage :geometry
  (:nicknames :geom :g)
  (:use :cl)
  (:shadow :+ :-)
  (:export :point
           :+ :-
           :pt
           :pt-from
           :rectangle
           :rect
           :rect-from
           :x :y :width :height
           :insidep
           :centerx
           :centery
           :right
           :bottom
           :overlap-p
           :horizontal-overlap-p
           :vertical-overlap-p
           :area
           :lines-collide-p))

(in-package :geometry)

(defclass point ()
  ((x :initarg :x :initform 0 :accessor x)
   (y :initarg :y :initform 0 :accessor y)))

(defgeneric + (a b))
(defgeneric - (a b))

(defmethod + ((p1 point) (p2 point))
  (pt (cl:+ (x p1) (x p2)) (cl:+ (y p1) (y p2))))

(defmethod - ((p1 point) (p2 point))
  (pt (cl:- (x p1) (x p2)) (cl:- (y p1) (y p2))))

(defmethod u:copy-slots progn ((node point) obj)
  (u:simple-copy-slots node obj 'x 'y))

(defun pt (x y)
  (make-instance 'point :x x :y y))

(defun pt-from (obj)
  (make-instance 'point :x (x obj) :y (y obj)))

(defmethod print-object ((obj point) stream)
  (print-unreadable-object (obj stream :type t)
    (format stream "~a,~a" (x obj) (y obj))))
    
(defclass rectangle (point)
  ((width :initarg :width :initform 0 :accessor width)
   (height :initarg :height :initform 0 :accessor height)))

(defgeneric centerx (obj))
(defgeneric centery (obj))
(defgeneric right (obj))
(defgeneric (setf right) (value obj))
(defgeneric bottom (obj))
(defgeneric (setf bottom) (value obj))

(defmethod + ((a rectangle) (b point))
  (rect (cl:+ (x a) (x b))
        (cl:+ (y a) (y b))
        (width a)
        (height a)))

(defmethod + ((b point) (a rectangle))
  (+ a b))

(defmethod - ((a rectangle) (b point))
  (rect (cl:- (x a) (x b))
        (cl:- (y a) (y b))
        (width a)
        (height a)))

(defmethod - ((b point) (a rectangle))
  (- a b))

(defmethod u:copy-slots progn ((node rectangle) obj)
  (u:simple-copy-slots node obj 'width 'height))

(defmethod print-object ((obj rectangle) stream)
  (print-unreadable-object (obj stream :type t)
    (format stream "~a,~a ~a,~a" (x obj) (y obj) (width obj) (height obj))))

(defun rect (x y w h)
  (make-instance 'rectangle :x x :y y :width w :height h))

(defun rect-from (thing)
  (rect (x thing) (y thing) (width thing) (height thing)))

(defun insidep (rect x y)
  (and (>= x (x rect))
       (>= y (y rect))
       (< x (cl:+ (x rect) (width rect)))
       (< y (cl:+ (y rect) (height rect)))))

(defmethod centerx ((rect rectangle))
  (cl:+ (x rect) (truncate (width rect) 2)))

(defmethod (setf centerx) (x (rect rectangle))
  (setf (x rect) (cl:- x (truncate (width rect) 2))))

(defmethod centery ((rect rectangle))
  (cl:+ (y rect) (truncate (height rect) 2)))

(defmethod (setf centery) (y (rect rectangle))
  (setf (y rect) (cl:- y (truncate (height rect) 2))))

(defmethod right ((rect rectangle))
  (cl:+ (x rect) (width rect)))

(defmethod (setf right) (value (rect rectangle))
  (setf (x rect) (cl:- value (width rect))))

(defmethod bottom ((rect rectangle))
  (cl:+ (y rect) (height rect)))

(defmethod (setf bottom) (value (rect rectangle))
  (setf (y rect) (cl:- value (height rect))))

(defun point (x y)
  (make-instance 'point :x x :y y))

(defun overlap-p (r1 r2)
  (not
   (or (< (right r1) (x r2))
       (< (bottom r1) (y r2))
       (> (x r1) (right r2))
       (> (y r1) (bottom r2)))))

(defun vertical-overlap-p (r1 r2 &optional (pad 0))
  (not
   (or (< (cl:+ (right r1) pad) (x r2))
       (> (x r1) (cl:+ (right r2) pad)))))

(defun horizontal-overlap-p (r1 r2)
  (not (or (< (bottom r1) (y r2))
           (> (y r1) (bottom r2)))))

(defun area (rect)
  (* (width rect) (height rect)))

(defun lines-collide-p (p1 p2 p3 p4)
  (labels ((in (p1 p2 x y)
             (psetf p1 (pt (min (x p1) (x p2))
                           (min (y p1) (y p2)))
                    p2 (pt (max (x p1) (x p2))
                           (max (y p1) (y p2))))
             (and (>= x (x p1))
                  (>= y (y p1))
                  (<= x (x p2))
                  (<= y (y p2)))))
    ;; standardize
    (when (or (< (x p2) (x p1))
              (< (y p2) (y p1)))
      (psetf p1 p2 p2 p1))
    (when (or (< (x p4) (x p3))
              (< (y p4) (y p3)))
      (psetf p3 p4 p4 p3))
    ;; vertical line special case
    (when (or (= (x p1) (x p2))
              (= (x p3) (x p4)))
      (setf p1 (pt (y p1) (x p1))
            p2 (pt (y p2) (x p2))
            p3 (pt (y p3) (x p3))
            p4 (pt (y p4) (x p4))))
    (cond
      ((and (= (x p1) (x p2))
            (= (x p3) (x p4)))
       (and (= (x p1) (x p3))
            (not (or (< (y p2) (y p3))
                     (< (y p4) (y p1))))))
      (t
        (let* ((m1 (/ (cl:- (y p2) (y p1))
                      (cl:- (x p2) (x p1))))
               (m2 (/ (cl:- (y p4) (y p3))
                      (cl:- (x p4) (x p3))))
               (b1 (cl:- (y p1) (* m1 (x p1))))
               (b2 (cl:- (y p3) (* m2 (x p3)))))
          (print `(,m1 ,m2 ,b1 ,b2))
          ;; parallel lines special case
          (if (= m1 m2)
              nil
              (let* ((x (/ (cl:- b2 b1) (cl:- m1 m2)))
                     (y (cl:+ (* m1 x) b1)))
                (print `(intersection ,x ,y))
                ;; is the point of intersection inside the bounding boxes of the
                ;; lines?
                (and (in p1 p2 x y)
                     (in p3 p4 x y)))))))))
    